home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / cl / pprint / globals.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  35KB  |  1,109 lines
  1. ;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
  2. ;;; Cambridge, Massachusetts.
  3.  
  4. (in-package "XP")
  5.  
  6. (defvar *xp-printing-functions*
  7.   '(write print prin1 princ pprint format write-to-string princ-to-string
  8.     prin1-to-string write-line write-string write-char terpri fresh-line
  9.     defstruct finish-output force-output clear-output)
  10.   "printing functions redefined by xp.")
  11.  
  12. ;;; Must do the following in common lisps not supporting *print-shared*
  13.  
  14. (defvar *print-shared* nil)
  15.  
  16. (defvar *print-pprint-dispatch* t ;see initialization at end of file.
  17.   "controls pretty printing of output")
  18.  
  19. (defvar *print-right-margin* nil
  20.   "+#/nil the right margin for pretty printing")
  21.  
  22. (defvar *print-miser-width* 40.
  23.   "+#/nil miser format starts when there is less than this width left")
  24.  
  25. (defvar *print-lines* nil
  26.   "+#/nil truncates printing after # lines")
  27.  
  28. (defvar *default-right-margin* 70.
  29.   "controls default line length; must be a non-negative integer")
  30.  
  31. (defvar *last-abbreviated-printing*
  32.   #'(lambda (&optional stream) (declare (ignore stream)) nil)
  33.   "funcalling this redoes the last xp printing that was abbreviated.")
  34.  
  35. (defvar *ipd* nil ;see initialization at end of file.
  36.   "initial print dispatch table.")
  37.  
  38. (defvar *current-level* 0
  39.   "current depth in logical blocks.")
  40.  
  41. (defvar *current-length* 0
  42.   "current position in logical block.")
  43.  
  44. (defvar *abbreviation-happened* nil
  45.   "t if current thing being printed has been abbreviated.")
  46.  
  47. (defvar *result* nil "used to pass back a value")
  48.  
  49. (defvar *locating-circularities* nil
  50.   "Integer if making a first pass over things to identify circularities.
  51.    Integer used as counter for #n= syntax.")
  52. (defvar *parents* nil "used when *print-shared* is nil")
  53.  
  54. (defvar *circularity-hash-table* nil
  55.   "Contains hash table used for locating circularities, or a stack.")
  56.  
  57. ;;; When an entry is first made it is zero.
  58. ;;; If a duplicate is found, a positive integer tag is assigned.
  59. ;;; After the first time the object is printed out, the tag is negated.
  60.  
  61. (defvar *free-circularity-hash-tables* nil
  62.   "free list of circularity hash tables") ; never bound
  63.  
  64. (defvar *preds-for-specs*
  65.   '((T always-true) (cons consp) (simple-atom simple-atom-p) (other otherp)
  66.     (null null) (symbol symbolp) (atom atom) (cons consp)
  67.     (list listp) (number numberp) (integer integerp)
  68.     (rational rationalp) (float floatp) (complex complexp)
  69.     (character characterp) (string stringp) (bit-vector bit-vector-p)
  70.     (vector vectorp) (simple-vector simple-vector-p) 
  71.     (simple-string simple-string-p) (simple-bit-vector simple-bit-vector-p)
  72.     (array arrayp) (package packagep) (function functionp)
  73.     (compiled-function compiled-function-p) (common commonp)))
  74.  
  75. (defvar *describe-xp-streams-fully* nil "Set to T to see more info.")
  76.  
  77. (defvar *free-xps* nil "free list of XP stream objects") ; never bound
  78.  
  79. (defvar *format-string-cache* T)
  80.  
  81. (defvar *fn-table* (make-hash-table) "used to access fns for commands")
  82.  
  83. (proclaim '(special *string* *used-args* *used-outer-args* *used-initial*
  84.         *get-arg-carefully* *inner-end* *outer-end* *at-top*
  85.         *default-package*))
  86.  
  87. (defvar *testing-errors* nil "Used only when testing XP")
  88.  
  89. (lisp:defstruct (pprint-dispatch (:conc-name nil) (:copier nil))
  90.   (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
  91.   (structures (make-hash-table :test #'eq) :type hash-table)
  92.   (others nil :type list))
  93.  
  94. ;;; The list and the hash-tables contain entries of the
  95. ;;; following form.  When stored in the hash tables, the test entry is 
  96. ;;; the number of entries in the OTHERS list that have a higher priority.
  97. (lisp:defstruct (entry (:conc-name nil))
  98.   (test nil)                ; predicate function or
  99.                     ; count of higher priority others.
  100.   (fn nil)                ; pprint function
  101.   (full-spec nil))            ; list of priority and type specifier
  102.  
  103. (eval-when (eval load compile)
  104.   (defun structure-type-p (x)
  105.     (gethash x lisp::*structure-info*))
  106.   
  107.   (defun output-width (&optional (s *standard-output*))
  108.     (declare (ignore s))
  109.     nil)
  110.   
  111.   (defun output-position (&optional (s *standard-output*))
  112.     (lisp::stream-column s))
  113.   )
  114.  
  115. (defun install (&key (package *package*) (macro nil) (shadow T) (remove nil))
  116.   (when (not (packagep package)) (setq package (find-package package)))
  117.   (when (not remove)
  118.     (when macro
  119.       (set-dispatch-macro-character #\# #\" #'format-string-reader))
  120.     (when (not (eq package (find-package "XP")))
  121.       (use-package "XP" package)
  122.       (when shadow (shadowing-import *xp-printing-functions* package))))
  123.   (when (and remove (member (find-package "XP") (package-use-list package)))
  124.     (unuse-package "XP" package)
  125.     (dolist (sym (intersection *xp-printing-functions*
  126.                    (package-shadowing-symbols package)))
  127.       (unintern sym package)))
  128.   T)
  129.  
  130. (defun get-circularity-hash-table ()
  131.   (let ((table (pop *free-circularity-hash-tables*)))
  132.     (if table table (make-hash-table :test 'eq))))
  133.  
  134. ;;; If you call this, then the table gets efficiently recycled.
  135. (defun free-circularity-hash-table (table)
  136.   (clrhash table)
  137.   (pushnew table *free-circularity-hash-tables*))
  138.  
  139. ;;;                       ---- DISPATCHING ----
  140.  
  141. (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
  142.   (when (null table) (setq table *IPD*))
  143.   (let* ((new-conses-with-cars
  144.       (make-hash-table :test #'eq
  145.                :size (max (hash-table-count
  146.                        (conses-with-cars table)) 32)))
  147.      (new-structures
  148.       (make-hash-table :test #'eq
  149.                :size (max (hash-table-count (structures table))
  150.                       32))))
  151.     (maphash #'(lambda (key value)
  152.          (setf (gethash key new-conses-with-cars) (copy-entry value)))
  153.          (conses-with-cars table))
  154.     (maphash #'(lambda (key value)
  155.          (setf (gethash key new-structures) (copy-entry value)))
  156.          (structures table))
  157.     (make-pprint-dispatch
  158.      :conses-with-cars new-conses-with-cars
  159.      :structures new-structures
  160.      :others (copy-list (others table)))))
  161.  
  162. (defun set-pprint-dispatch (type-specifier function
  163.                        &optional
  164.                        (priority 0)
  165.                        (table *print-pprint-dispatch*))
  166.   (when (or (not (numberp priority)) (complexp priority))
  167.     (error "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" priority))
  168.   (set-pprint-dispatch+ type-specifier function priority table))
  169.  
  170. (defun set-pprint-dispatch+ (type-specifier function priority table)
  171.   (let* ((category (specifier-category type-specifier))
  172.      (pred
  173.       (if (not (eq category 'other))
  174.           nil
  175.           (let ((pred (specifier-fn type-specifier)))
  176.         (if (and (consp (caddr pred))
  177.              (symbolp (caaddr pred))
  178.              (equal (cdaddr pred) '(x)))
  179.             (symbol-function (caaddr pred))
  180.             (compile nil pred)))))
  181.      (entry (if function
  182.             (make-entry :test pred
  183.                 :fn function
  184.                 :full-spec (list priority type-specifier)))))
  185.     (case category
  186.       (cons-with-car
  187.        (cond ((null entry)
  188.           (remhash (cadadr type-specifier) (conses-with-cars table)))
  189.          (T (setf (test entry)
  190.               (count-if #'(lambda (e)
  191.                     (priority-> (car (full-spec e)) priority))
  192.                 (others table)))
  193.         (setf (gethash (cadadr type-specifier)
  194.                    (conses-with-cars table)) entry))))
  195.       (structure-type
  196.        (cond ((null entry) (remhash type-specifier (structures table)))
  197.          (T (setf (test entry)
  198.               (count-if #'(lambda (e)
  199.                     (priority-> (car (full-spec e)) priority))
  200.                 (others table)))
  201.         (setf (gethash type-specifier (structures table)) entry))))
  202.       (T                ;other
  203.        (let ((old (car (member type-specifier (others table) :test #'equal
  204.                    :key #'(lambda (e) (cadr (full-spec e)))))))
  205.      (when old
  206.        (setf (others table) (delete old (others table)))
  207.        (adjust-counts table (car (full-spec old)) -1)))
  208.        (when entry
  209.      (let ((others (cons nil (others table))))
  210.        (do ((l others (cdr l)))
  211.            ((null (cdr l)) (rplacd l (list entry)))
  212.          (when (priority-> priority (car (full-spec (cadr l))))
  213.            (rplacd l (cons entry (cdr l)))
  214.            (return nil)))
  215.        (setf (others table) (cdr others)))
  216.      (adjust-counts table priority 1)))))
  217.   nil)
  218.  
  219. (defun priority-> (x y)
  220.   (if (consp x)
  221.       (if (consp y) (> (car x) (car y)) nil)
  222.       (if (consp y) T (> x y))))
  223.  
  224. (defun adjust-counts (table priority delta)
  225.   (maphash #'(lambda (key value)
  226.            (declare (ignore key))
  227.            (if (priority-> priority (car (full-spec value)))
  228.            (incf (test value) delta)))
  229.        (conses-with-cars table))
  230.   (maphash #'(lambda (key value)
  231.            (declare (ignore key))
  232.            (if (priority-> priority (car (full-spec value)))
  233.            (incf (test value) delta)))
  234.        (structures table)))
  235.  
  236. (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
  237.   (when (null table) (setq table *IPD*))  
  238.   (let ((fn (get-printer object table)))
  239.     (values (or fn #'non-pretty-print) (not (null fn)))))
  240.  
  241. (defun get-printer (object table)
  242.   (let* ((entry (if (consp object)
  243.             (gethash (car object) (conses-with-cars table))
  244.             (gethash (type-of object) (structures table)))))
  245.     (if (not entry)
  246.     (setq entry (find object (others table) :test #'fits))
  247.     (do ((i (test entry) (1- i))
  248.          (l (others table) (cdr l)))
  249.         ((zerop i))
  250.       (when (fits object (car l)) (setq entry (car l)) (return nil))))
  251.     (when entry (fn entry))))
  252.  
  253. (defun fits (obj entry) (funcall (test entry) obj))
  254.  
  255. (defun specifier-category (spec)
  256.   (cond ((and (consp spec)
  257.           (eq (car spec) 'cons)
  258.           (consp (cdr spec))
  259.           (null (cddr spec))
  260.           (consp (cadr spec))
  261.           (eq (caadr spec) 'member)
  262.           (consp (cdadr spec))
  263.           (null (cddadr spec)))
  264.      'cons-with-car)
  265.     ((and (symbolp spec) (structure-type-p spec)) 'structure-type)
  266.     (T 'other)))
  267.  
  268. (defun always-true (x) (declare (ignore x)) T)
  269.  
  270. (defun specifier-fn (spec)
  271.   `(lambda (x) ,(convert-body spec)))
  272.  
  273. (defun convert-body (spec)
  274.   (cond ((atom spec)
  275.      (let ((pred (cadr (assoc spec *preds-for-specs*))))
  276.        (if pred `(,pred x) `(typep x ',spec))))
  277.     ((member (car spec) '(and or not))
  278.      (cons (car spec) (mapcar #'convert-body (cdr spec))))
  279.     ((eq (car spec) 'member)
  280.      `(member x ',(copy-list (cdr spec))))
  281.     ((eq (car spec) 'cons)
  282.      `(and (consp x)
  283.        ,@(if (cdr spec) `((let ((x (car x)))
  284.                 ,(convert-body (cadr spec)))))
  285.        ,@(if (cddr spec) `((let ((x (cdr x)))
  286.                  ,(convert-body (caddr spec)))))))
  287.     ((eq (car spec) 'satisfies)
  288.      `(funcall (function ,(cadr spec)) x))
  289.     (T `(typep x ',(copy-tree spec)))))
  290.  
  291. ;;;                ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ----
  292.  
  293. (eval-when (eval load compile) ;not used at run time.
  294.   (defvar block-stack-entry-size 1)
  295.   (defvar prefix-stack-entry-size 5)
  296.   (defvar queue-entry-size 7)
  297.   (defvar buffer-entry-size 1)
  298.   (defvar prefix-entry-size 1)
  299.   (defvar suffix-entry-size 1))
  300.  
  301. (eval-when (eval load compile) ;used at run time
  302.   (defvar block-stack-min-size #.(* 35. block-stack-entry-size))
  303.   (defvar prefix-stack-min-size #.(* 30. prefix-stack-entry-size))
  304.   (defvar queue-min-size #.(* 75. queue-entry-size))
  305.   (defvar buffer-min-size 256.)
  306.   (defvar prefix-min-size 256.)
  307.   (defvar suffix-min-size 256.)) 
  308.  
  309. (lisp:defstruct (xp-structure (:conc-name nil) (:print-function describe-xp))
  310.   (base-stream nil)            ; The stream io eventually goes to.
  311.   linel                    ; The line length to use in formatting.
  312.   line-limit                ; If true, max  lines to print.
  313.   line-no                ; number of next line to be printed.
  314.   char-mode                ; NIL :UP :DOWN :CAP0 :CAP1 :CAPW
  315.   char-mode-counter            ; depth of nesting of ~(...~)
  316.   depth-in-blocks
  317.   ;; Number of logical blocks at QRIGHT that are started but not ended.
  318.   (block-stack (make-array #.block-stack-min-size))
  319.   BLOCK-STACK-PTR
  320.   ;; This stack is pushed and popped in accordance with the way blocks are 
  321.   ;; nested at the moment they are entered into the queue.  It contains the 
  322.   ;; following block specific value.
  323.   ;; SECTION-START total position where the section (see AIM-1102)
  324.   ;; that is rightmost in the queue started.
  325.   (BUFFER (make-array #.buffer-min-size
  326.               :element-type 'string-char))
  327.   charpos
  328.   buffer-ptr
  329.   buffer-offset
  330.   ;; This is a vector of characters (eg a string) that builds up the
  331.   ;; line images that will be printed out.  BUFFER-PTR is the
  332.   ;; buffer position where the next character should be inserted in
  333.   ;; the string.  CHARPOS is the output character position of the
  334.   ;; first character in the buffer (non-zero only if a partial line
  335.   ;; has been output).  BUFFER-OFFSET is used in computing total lengths.
  336.   ;; It is changed to reflect all shifting and insertion of prefixes so that
  337.   ;; total length computes things as they would be if they were 
  338.   ;; all on one line.  Positions are kept three different ways
  339.   ;; Buffer position (eg BUFFER-PTR)
  340.   ;; Line position (eg (+ BUFFER-PTR CHARPOS)).  Indentations are stored in this form.
  341.   ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
  342.   ;;  Positions are stored in this form.
  343.   (QUEUE (make-array #.queue-min-size)) QLEFT QRIGHT
  344.   ;; This holds a queue of action descriptors.  QLEFT and QRIGHT
  345.   ;; point to the next entry to dequeue and the last entry enqueued
  346.   ;; respectively.  The queue is empty when
  347.   ;; (> QLEFT QRIGHT).  The queue entries have several parts:
  348.   ;; QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
  349.   ;; QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
  350.   ;;  or :BLOCK/:CURRENT
  351.   ;; QPOS total position corresponding to this entry
  352.   ;; QDEPTH depth in blocks of this entry.
  353.   ;; QEND offset to entry marking end of section this entry starts. (NIL until known.)
  354.   ;;  Only :start-block and non-literal :newline entries can start sections.
  355.   ;; QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
  356.   ;; QARG for :IND indentation delta
  357.   ;;     for :START-BLOCK suffix in the block if any.
  358.   ;;                      or if per-line-prefix then cons of suffix and
  359.   ;;                      per-line-prefix.
  360.   ;;     for :END-BLOCK suffix for the block if any.
  361.   (PREFIX (make-array #.buffer-min-size :element-type
  362.               #-symbolics 'string-char #+symbolics 'character))
  363.   ;; this stores the prefix that should be used at the start of the line
  364.   (PREFIX-STACK (make-array #.prefix-stack-min-size)) PREFIX-STACK-PTR
  365.   ;; This stack is pushed and popped in accordance with the way blocks 
  366.   ;; are nested at the moment things are taken off the queue and printed.
  367.   ;; It contains the following block specific values.
  368.   ;; PREFIX-PTR current length of PREFIX.
  369.   ;; SUFFIX-PTR current length of pending suffix
  370.   ;; NON-BLANK-PREFIX-PTR current length of non-blank prefix.
  371.   ;; INITIAL-PREFIX-PTR prefix-ptr at the start of this block.
  372.   ;;SECTION-START-LINE line-no value at last non-literal break at this level.
  373.   (SUFFIX (make-array #.buffer-min-size :element-type 'string-char)))
  374.  
  375. ;;; this stores the suffixes that have to be printed to close of the current
  376. ;;; open blocks.  For convenient in popping, the whole suffix
  377. ;;; is stored in reverse order.
  378.  
  379.  
  380. (defmacro LP<-BP (xp &optional (ptr nil))
  381.   (if (null ptr) (setq ptr `(buffer-ptr ,xp)))
  382.   `(+ ,ptr (charpos ,xp)))
  383.  
  384. (defmacro TP<-BP (xp)
  385.   `(+ (buffer-ptr ,xp) (buffer-offset ,xp)))
  386.  
  387. (defmacro BP<-LP (xp ptr)
  388.   `(- ,ptr (charpos ,xp)))
  389.  
  390. (defmacro BP<-TP (xp ptr)
  391.   `(- ,ptr (buffer-offset ,xp)))
  392.  
  393. ;;; This does not tell you the line position you were at when the TP
  394. ;;; was set, unless there have been no newlines or indentation output 
  395. ;;; between ptr and the current output point.
  396. (defmacro LP<-TP (xp ptr)
  397.   `(LP<-BP ,xp (BP<-TP ,xp ,ptr)))
  398.  
  399. ;;; We don't use adjustable vectors or any of that, because we seldom have
  400. ;;; to actually extend and non-adjustable vectors are a lot faster in
  401. ;;; many Common Lisps.
  402. (defmacro check-size (xp vect ptr)
  403.   (let* ((min-size
  404.       (symbol-value
  405.        (intern (concatenate 'string (string vect) "-MIN-SIZE")
  406.            (find-package "XP"))))
  407.      (entry-size
  408.       (symbol-value
  409.        (intern (concatenate 'string (string vect) "-ENTRY-SIZE")
  410.            (find-package "XP")))))
  411.     `(when (and (> ,ptr ,(- min-size entry-size)) ;seldom happens
  412.         (> ,ptr (- (length (,vect ,xp)) ,entry-size)))
  413.       (let* ((old (,vect ,xp))
  414.          (new (make-array (+ ,ptr ,(if (= entry-size 1) 50
  415.                        (* 10 entry-size)))
  416.                   :element-type (array-element-type old))))
  417.     (replace new old)
  418.     (setf (,vect ,xp) new)))))
  419.  
  420. (defmacro section-start (xp) `(aref (block-stack ,xp) (block-stack-ptr ,xp)))
  421.  
  422. (defun push-block-stack (xp)
  423.   (incf (block-stack-ptr xp) #.block-stack-entry-size)
  424.   (check-size xp block-stack (block-stack-ptr xp)))
  425.  
  426. (defun pop-block-stack (xp)
  427.   (dec=block-stace new olnon-blank p(+ ,ptr ( new))of the line
  428. cro secof the line
  429.  xp) `(aref (blocnew old (defvnk p(+ ,ptr ( new))of the line
  430. cro sec+ecof the line
  431.  xp) `(ar-entf (blocnew ol;; NON-BL-non-blank p(+ ,ptr ( new))of the line
  432. cro sec+ecof the line
  433.  xp) `(ar-2ntf (blocnew olinicter-non-blank p(+ ,ptr ( new))of the line
  434. cro sec+ecof the line
  435.  xp) `(ar-3(replace new old)
  436.     (setf (,v-s form+ ,ptr ( new))of the line
  437. cro sec+ecof the line
  438.  xp) `(ar-4ref (block-stack of the line
  439. ck-stack- (cadr(ar.
  440.   ;;  0sec(ar. per-li0sec(ar.;; NON-BLA0car l)) (setqof obefmau    of the line
  441.  xp) 
  442.   (if ( l)) xp &o(ar.
  443.   ;;  (non-blank p-sta-size(ar. per-li(d (defvnk p-sta-size(ar.;; NON-BLA(;; NON-BL-non-blank p
  444.   (if ( ltr ,xp)of the line
  445.  xp) 
  446.   rt of the line
  447.   (incf (block-k-stack-ptr xp) #of the line
  448. ckof the line
  449.  xp) 
  450.   (
  451.  l)) xp f (non-blank p-sto(ar.
  452.   ;; (
  453.  l)) xp f (d (defvnk p-ste(ar. per-l(
  454.  l)) xp f (;; NON-BL-non-blank p
  455.   e(ar.;; NON-BLck-size xp blockof the line
  456. ck-stack-ptr xpof the line
  457.  xp) 
  458.   rt of the line
  459.   (incf (blof (blocnew olQ)))
  460.      ;; maet, x,xp) new))ed at `(ar-,et, x,f (blocnew olQ thd     ;; maet, x,xp) new))ed at `(ar-(1+-,et, x,ff (blocnew olQ(def     ;; maet, x,xp) new))ed at `(ar-(+-,et, x-2ntf (blocnew olQn corr;; maet, x,xp) new))ed at `(ar-(+-,et, x-3(replace new olQehd     ;;; maet, x,xp) new))ed at `(ar-(+-,et, x-4(replace new olQfmacro ; maet, x,xp) new))ed at `(ar-(+-,et, x-5(replace new olQarg     ;;; maet, x,xp) new))ed at `(ar-(+-,et, x-6P (xp ptrdjusngth nested at opin rau we We n<-Bs.
  461.    circul#.(* 30.n't use er-min-s noorng tut))
  462.  
  463. ;;;lly extend and #of) QLcwoulNotse rac,ve thistuter-mi `(- ,ptrppin  use aausngth,ause p))
  464. nd #lo.
  465.   thistut, nested at iser-misngtht ileth ne-pf;; appinyeval- it (> ,ptr in bnqueuthe
  466. ize xp b next e ; ma)))
  467.      thd     in reversargck-ptr ,xp)Qe the 
  468.   rt -size))
  469.   (defvar
  470. )) (setqo>p)Qe the 
  471.   rt ent* 30. prefix-st-size))
  472.   (defvar que)) lement-t)ed at (ar-(ed at (ar-try st2p)Qleth (ar-tehd2p)Qe the 
  473.   (
  474.  l)) xp f (Qe the 
  475.   rentrQe the 
  476.   reQleth (ar (
  477.  l)) xp f (Qleth (ar-0car lstack-ptr xp) #ext e ;Qe the 
  478.   (
  479.  l xp f (Q)))
  480.     nt.
  481. Qe the 
  482.   (a)))
  483. (
  484.  l xp f (Q thd    nt.
  485. Qe the 
  486.   (a thd(
  487.  l xp f (Q(defnt.
  488. Qe the 
  489.   (a()))
  490.   `
  491.   (
  492.  l xp f (Qn corrnt.
  493. Qe the 
  494.   (a(counter            ; dep`
  495.   (
  496.  l xp f (Qehd    nt.
  497. Qe the 
  498.   (aer.
  499.  
  500.  l xp f (Qfmacro nt.
  501. Qe the 
  502.   (aer.
  503.  
  504.  l xp f (Qarg    nt.
  505. Qe the 
  506.   (aargceplace new olQtors.(et, x,xp)+-,et, x-t -size))
  507.   (defvar-size xp bructure (:c ; mason cor) ack-ptrlctua(ignenton cor)tack- 56.).
  508.   liaso"#<XP describ"
  509.  
  510. (defmacr obeme nil) (:pr
  511.   (
  512.  l))ck- 56.).
  513.   liaso"r obdentatifirsn<-Be"(
  514.  l))ck- 56.).
  515.   liaso"n outpn outpu ~S"beme nil) (:pr
  516.   (r
  517. )) (setqome nil) (:pr
  518.   
  519. ))ck- 56.).
  520.   liaso"~¯o = ~S"besubseqp)))
  521.  
  522. (d (ar-0
  523.    xharpos ,xp)))(ar-0caar l)) (setqof ob*ructure (:cil) (:ps-fo Ly*)k- 56.) thic " ar-" saar l)) (setq*ructure (:cil) (:ps-fo Ly*
  524.  l))ck- 56.).
  525.   liaso"~&consdef     _123456789_123456789_123456789_123456789"(
  526.  l))ck- 56.).
  527.   liaso"~&counter            ; dep= ~Dset ,l= ~Dset ,.;;= ~Dset ,.limit= ~D"enate 'counter            ; dep`
  528.   k- 5 ,l`
  529.   k- 5 ,of t
  530.   k- 5 ,olimitr
  531.   (
  532.  l))ck-(setqooxp)))
  533.  
  534. -modt (ar-(r obee
  535.   pp)))
  536.  
  537. -modt-cou))))r
  538.   (rray- 56.).
  539.   liaso"~&))
  540.  
  541. -modt= ~S ))
  542.  
  543. -modt-cou))))= ~D"enate  p)))
  544.  
  545. -modt (ar-())
  546.  
  547. -modt-cou))))r
  548.   (r
  549.  l))ck-tion yoefmau    entry-size)
  550.   (checkay- 56.).
  551.   liaso"~&d)
  552.     (setf (,vaten(doadrsat w-entry-size)
  553.   (check-s,(- miefmau    entry-size)
  554.   (checkl xp f ()))
  555.  
  556. (defun pop-blocsat k-s,(-- 56.).
  557.   liaso" ~D"l xp
  558.     (setf (,ve ,entry-(lock-stack (bloc
  559.   (r
  560.  l))ck- 56.).
  561.   liaso"~&et ,l= ~Ds))
  562.  
  563. (de= ~Dsrpos ,xp))= ~Dsrpos ,xfmacro= ~D"enate ' 5 ,l`
  564.   k-))
  565.  
  566. (def
  567. (defmacro Tpop-bloc)))
  568.  
  569. (defmacro 
  570.   (
  571.  l))ck-tion yoefmau    of the line
  572.  xp) 
  573.   (
  574. y- 56.).
  575.   liaso"~&
  576.   ;; = ~S"enate  p)subseqp)
  577.   ;;  (ar-0
  578.    xhanon-blank p
  579.   e0(rray- 56.).
  580.   liaso"~& per-l= ~S"enate  p)subseqp) per-li(ar-0
  581.    xhad (defvnk p-ste0) (r
  582.  l))ck-tion yoe> (Qleth (ar-;Qe the 
  583.   (
  584. y- 56.).
  585.   liaso"~&
  586. op-)))
  587.      ;;;;;;; thd     ;then consoson cors entryacro argaten(doadrp (Qleth (ar-;Qtors.eck-adr> t.
  588. Qe the 
  589.   (-s,(-- 56.).
  590.   liaso"~&~4A~13A~15A~4A~6A~4A~7A~A"enate  pck-/rentp (Qleth (ar rt -size))
  591.   (defvar
  592. nate  pck-Q)))
  593.     nt.pr
  594. nate  pck-fmacmemb))r-Q)))
  595.     nt.pr '()
  596.   ;;  O:thd() (Q thd    nt.pr ""r
  597. nate  pck-(defmacnt.
  598. Q(defnt.  (
  599. yate  pck-Qn corrnt.pr
  600. nate  pck-fmacf obefemb))r-Q)))
  601.     nt.pr '()
  602.   ;;  O:ry starts. ck-a""try-siz)
  603.           Qehd    nt.pr
  604. na        -/rent)+-p  Qehd    nt.pr) (Qleth (ar rt -size))
  605.   (defvar)r
  606. nate  pck-fmacf obeeqp)Q)))
  607.     nt.pr :ry starts. cka""try-siz)
  608.           Qfmacro nt.pr
  609. na        -/rent)+-p  Qfmacro nt.pr) (Qleth (ar rt -size))
  610.   (defvar)r
  611. nate  pck-fmacf obefemb))r-Q)))
  612.     nt.pr '()thd    try starts. (tehdarts. ck-a""try-siz)Qarg    nt.p))) (
  613.  l))ck-tion yoefmau    of the line
  614.  xp) 
  615.   (
  616. y- 56.).
  617.   liaso"~&inicter-non-blank pnon-blank pd (defvnk p;; NON-BLAf (,v-s foaten(doadrsat w-of the line
  618.  xp) 
  619.   (if,(- miefmau    of the line
  620.  xp) 
  621.   () xp f (non-bladefun pop-blocsat k-s,(-- 56.).
  622.   liaso"~&c~19A~11A~11A~10A~A"enate  pck-inicter-non-blank po secof the nk po secd (defvnk p-sta-ate  pck-;; NON-BL-non-blank p
  623.   e(d)
  624.     (setf (,v-s for ,entry-(lockof the line
  625. cxp))) (
  626.  l- 56.) thic ">" sa
  627. ))  It coTP (xp ptr)
  628.  men ken ofllyis INITXP desuy oeleoul)
  629.  sat wnesmer-misoin-s no
  630.   `(LP<har)))
  631.  
  632. c (:t-type (; waf t suffixeval-.p ptr)
  633.  har))sep  #t-tobj)
  634.     sisoin-s ndjustc n<;;;sn<-Bees nent-.p ptr(Notsaracter) (: thab
  635.   `IX.
  636.  h t ts. IX.
  637.  weron'ut)CLi `(- ,ptrhat wnesp ptr thmitiv(- ne-pitoulT wereioflln oyr tobabiTIOy
  638.  werin-s ntwo dios ,at have  tocn y(- ccter)ehd    uma)ry outpu -Beeent-tamor ,il) (:p)ize xp bget-nontty- thisil) (:pr(l) (:p)ick- (cadrnt.
  639. loc *f;; (:cs* (if ( ltr icterfva(:c ;fma:c :c ;      ,il) uy oelk-al) (:p)TP (xp pIf; Thicf t n-si, nest ,il) (:pbgets e(deciatifirrecyclt thze xp bf;; (nontty- thisil) (:pr(-stack-xp f ()e nil) (:pr
  640.   aer.
  641.  
  642.  l tackype xc *f;; (:cs* ( (xp ptr)
  643.  )
  644.  cf t storer icterfva way blo(setq Thif (,venontty  thisy bthze xp br icterfva(:c ; mas) (:p)ick-xp f ()e nil) (:pr
  645.   as) (:p)ick-xp f ( 5 ,l`
  646.   k-  xh0     (en      * thisie the-margin*r
  647. na        -(n outp-widorrl) (:p)T
  648. na        -Tq*rufaulsie the-margin*r)))ick-xp f ( 5 ,olimitr
  649.    * thisi;;; w*)ick-xp f ( 5 ,of t
  650.   k1)ick-xp f ())
  651.  
  652. -modt (ar-er.
  653.  
  654.  l xp f ())
  655.  
  656. -modt-cou))))r
  657.   e0)
  658.  l xp f (counter            ; dep`
  659.   k0)
  660.  l xp f ()))
  661.  
  662. (defun pop-bloc0
  663.  
  664.  l xp f ())
  665.  
  666. (def
  667. (def(en      (n outp-p)))
  668.  
  669. ;;;l) (:p)Ta()-0caar l xp f (dp
  670.     (setf (,ve ,ek0)
  671.  l xp f ()pos ,xp)))(ar-0c
  672.  l xp f ()pos ,xfmacro 
  673.    ())
  674.  
  675. (def
  676. (d
  677.  
  678.  l xp f (Qleth (ar-0c
  679. )) xp f (Qe the 
  680.   rt ent* 30. )
  681.   (defvar que xp f (non-bladefun pop-bloct entof the line
  682.   (incf (blof  p-sta(xp ptre ))
  683.  
  684. -modt;l) (deiofllbitr-vacky.p ptr(; tc n<;;;sn<(; tsuffixefollow outmodts:p ptrNILthe ))
  685. nger in ))
  686.  
  687. ) Qerson outp.p ptr:UP CHAR-UPCASE -Bed.p ptr:DOWN CHAR-DOWNCASE -Bed.p ptr:CAP0tc piterfva tors.alp)
  688. numevacilettwe Weetqswitch in :DOWN.p ptr:CAP1tc piterfva tors.alp)
  689. numevacilettwe Weetqswitch in :CAPWp ptr:CAPWi `wntrBeelettweeoul)eetqanoord b (:kilettwe fou)d,qswitch in :CAP1.p ptrIteiofp))siave
  690. ne-p~(~)))
  691.  
  692. ;;;; wht iitqan.
  693.   lias-valuon'ut)notsan-s p ptreach modt;lpecifielo(sliasacter)(> ,pt in bpinyelettweoulT wer.
  694.  roninnerp ptr; wht imodtsr; pin hat wjuste(d)
  695.     oulYThicfn dom  ignentonesm. (block-stack ))
  696.  
  697. -modt;; maype-modt
  698.  
  699. (defmace
  700.   pp)))
  701.  
  702. -modt-cou))))r
  703.   (f ( l)) xp f ())
  704.  
  705. -modt (ar-epe-modt
  706. ck-ptr ,xp)))
  707.  
  708. -modt-cou))))r
  709.   (r
  710. ize xp block))
  711.  
  712. -modt;; mtack-ptr xp))
  713.  
  714. -modt-cou))))r
  715.   (f (efmace
  716.   pp)))
  717.  
  718. -modt-cou))))r
  719.   (f ( l)) xp f ())
  720.  
  721. -modt (ar-er.
  722.  ( (xp pAssume
  723.  )
  724.  only cf t st(setq))
  725.  
  726. -modt;isp;; Ner.ize xp b)
  727. ndle ))
  728.  
  729. -modt;; ma))
  730.  
  731. ar lstrBee())
  732.  
  733. -modt (arf ( lt:CAP0tf(en      (f obealp)
  734. numevacma))
  735.  
  736. a)a))
  737.  
  738. ary-s()- xp f ())
  739.  
  740. -modt (ar-:DOWNr-())
  741.  
  742. -uptrBee))
  743.  
  744. a))rf ( lt:CAP1tf(en      (f obealp)
  745. numevacma))
  746.  
  747. a)a))
  748.  
  749. ary-s()- xp f ())
  750.  
  751. -modt (ar-:CAPWr-())
  752.  
  753. -uptrBee))
  754.  
  755. a))rf ( lt:CAPWtf(en      (alp)
  756. numevacma))
  757.  
  758. a-())
  759.  
  760. - `wntrBee))
  761.  
  762. a)ry-s()- xp f ())
  763.  
  764. -modt (ar-:CAP1)e))
  765.  
  766. a))f ( lt:UP ())
  767.  
  768. -uptrBee))
  769.  
  770. a)f ( ltT-())
  771.  
  772. - `wntrBee))
  773.  
  774. a)a)a;:DOWN (xp pA t ))
  775.  
  776. ) Qerson outp ctuapa y(stohroughffixe)
  777. ndler abopi.p ptrHow pin, it mom p ptr;;;;ot(stohs nen-each-s forof the waftuaonly  tocn y(dp ptritqfixe(entors.suffixp ptrfirm  ment-tfixy > ,paeoulT wyif (yeent-tamorlatwe he  litwe (slioulAlsop ptr;en-TIOerers
  778.   ;;  sono ,ptrcou)) asnoord b (:ks.(xp ptr)
  779.  )
  780. ndleseent-)e acin outpn outsuf))
  781.  
  782. ) Qersoulnotsa+pd (def meatr i-s p ptrent-t) (:pr)
  783.  kn`wn))
  784.  
  785. ;;;ln XP descri,af t inutpwaftuadjudatory,ause nop ptrerre-ptack-IX.
  786.  as))
  787.  
  788. ;;; `(woulS (def ++ addi reverly meatr i-s ffixp ptrn outp )
  789.  gu
  790.  
  791. )ntoed ,ptrin )o ken qan
  792.   ;;  O))
  793.  
  794. thze xp bwrIOe ))
  795.  
  796. +-())
  797.  
  798.  (arf (efmaceqt ))
  799.  
  800.  #\
  801.   ;;  seco thisi
  802.   ;;  + :un(en    i rever (arf ( lck-(rIOe ))
  803.  
  804. ++ ))
  805.  
  806.  (ar(r
  807. ize xp b(rIOe s-valu+r(l) IX.
  808.  mas)(,veehd(
  809.  l  (cadrsub-ehd    er.
  810.  torsi
  811.   ;;   
  812. ))ck- o pp)xp &otorsi
  813.   ;;  ry-(p)))
  814.  
  815. ;;;#\
  816.   ;;  as-valutry-si:t wh #'))
  817.  
  818. =    try stas)(,vetehdeehd(ntry-(xp &osub-ehd    efmatorsi
  819.   ;;  atorsi
  820.   ;;  aehd(ntry-((rIOe s-valu++ l) IX.
  821.  mas)(,vesub-ehdntry-((setqofo L torsi
  822.   ;;   ) le oen-er.
  823.  try-(l thisi
  824.   ;;  + :un(en    i rever (arfry-(xp &os)(,ve(1+-sub-ehdn)
  825.  ( (xp pnotsan-)
  826.  cack-yoe> BUFFER-PTR LINEL) inwhtantryoe> (L))
  827.   ) LINEL)p ptren)
  828.  )
  829.  impc,v)ntisoin-s nosetqway bloftualo.
  830. we We n<aset ,tfixyp ptrehd    umagetn out thist iitqchunng tf tr xpLINEL.
  831. hze xp bwrIOe ))
  832.  
  833. ++-())
  834.  
  835.  (arf (e(setqo>p)macro Tpop-bloc) 5 ,l`
  836.    
  837. ))ck-.
  838.  ce sh t-n outp 
  839.   (f (e (cadrepe-)pos ,xehd    e1+-)macro Tpop-bloa))f ( lttack-ptr xp) #))
  840.  
  841. (d epe-)pos ,xehdif ( ltrf ())
  842.  
  843. -modt (ar-(xp &o))
  844.  
  845.  ()
  846. ndle ))
  847.  
  848. -modt; ma))
  849.  
  850. a (
  851.  l)) xp f ())
  852.  
  853.  ())
  854.  
  855. (d (ar-)macro Tpop-bloaa))
  856.  
  857. a----
  858.  l)) xp f (macro Tpop-blocepe-)pos ,xehdi(r
  859. ize xp b.
  860.  ce sh t-n outp ; mtack-litwnqu-to-n outp 
  861.  -er.-er.
  862.  
  863.  l (setqo>p)macro Tpop-bloc) 5 ,l`
  864.     ;only rf  thisy btryas entryset ,
  865.  l)) litwnqu-to-n outp 
  866.  -T Tr(r
  867. ize xp b(rIOe s-valu++r(l) IX.
  868.  mas)(,veehd(
  869.  l (setqo>p)macro Tpop-bloc) 5 ,l`
  870.    
  871. ))ck-.
  872.  ce sh t-n outp 
  873.   (f (e(rIOe s-valu+++ l) IX.
  874.  mas)(,veehd(ntp ptr; vwe fo ceson outptrenter.
  875.  r-taf)))
  876.  
  877. cf t from withsn<( outp-et ,.ize xp b(rIOe s-valu+++r(l) IX.
  878.  mas)(,veehd( f (e (cadrepe-)pos ,xehd    e+p)macro Tpop-bloc)-s ents)(,voa))f ( lttack-ptr xp) #))
  879.  
  880. (d epe-)pos ,xehdif ( ltdoadr))
  881.  
  882. (d ())
  883.  
  884. (d (arrfry(ip)macro Tpop-bloc)1+-irrfry(jos)(,ve(1+-j(rray-(= jeehd(nt l))ck- (cadr))
  885.  
  886.  ())
  887.  
  888.  l) IX.
  889. j(rray-rf ())
  890.  
  891. -modt (ar-(xp &o))
  892.  
  893.  ()
  894. ndle ))
  895.  
  896. -modt; ma))
  897.  
  898. a (
  899.      xp f ())
  900.  
  901.  ))
  902.  
  903. (d i)a))
  904.  
  905. a (
  906.  l)) xp f (macro Tpop-blocepe-)pos ,xehdi(r
  907. ize xp bl thisitab+p) thd    colnum    colhic  mtack- (cadret, ist ?    er.
  908.   lelativ(?-er.
  909.  t ( lttrBee thdt l))ck-:dp
  910.     (se-(xp &oet, ist ?    T(nt l))ck-: 5 ,olelativ(-(xp &olelativ(?-T(nt l))ck-:dp
  911.     (setlelativ(-(xp &oet, ist ?    Tolelativ(?-T(n 
  912. ))ck- et*adr)entatif,(- mifmacf obet, ist ?) (L))
  913.   p-sta-aent)T))
  914.   p-stl xp
  915.     (setf (,ve ,en(if,(- repef,(- mifmace
  916.   ppcolhicta-aefmalelativ(?-e+p)entati    colnum k-  xhcolnum    centatia)ry-f(en      lelativ(?a-ate  pck-*    colhic (f o r-e+p)entati    colnum    colhic -1)e)olhict)r
  917. nate  pcdr> colnum    centatia    colnum 
  918. nate  pcdT-e+p)olnumtry-sizk-*    colhictry-sizk)ck-. o r-e+p)entati    entcolnum kcolhicta-ay-sizk)c)olhict)ren(if,(- rlengorrentype centatia)(
  919.  l))ck-(setqoplu   lengorray-rf ())
  920.  
  921. -modt (ar-()
  922. ndle ))
  923.  
  924. -modt; ma#\spnt- (
  925. y- (cadrehd    e+p)macro Tpop-bloclengorr
  926.  try-(tack-ptr xp) #))
  927.  
  928. (d ehdntry-(fi t ())
  929.  
  930. (d (ar-#\spnt-    try sta)macro Tpop-bloctehdeehd(fry-(xp f (macro Tpop-blocehdn)
  931.  (ntp ptrNotsafollow out)
  932.  smf t wh numb))r>= xin-s niofllmulsipl tsufcolhict ptrk-*    colhic (f o r-e+pxha1-c)olhict)c)olhict)ize xp bl thisi
  933.   ;;  + ( thd    nttack-en* 30.p) #)
  934.   ;;  O thdtack-poadrptr (Qleth (ar-;Qtors.et
  935. a ())ck;fthd    dp
  936.     (sesno
  937.  ftuaehdalutte  pcdrf obe< ptr (Qe the 
  938.   (-)    ;f t 'ut)lam p))ck-(setqo
  939.           fo L  Qehd    nt.ptr(if,(- mpck-;;tqo>p)counter            ; dep`
  940.   k-Qn corrnt.ptr)(if,(- mpck-femb))r-Q)))
  941.     nt.ptr) '()
  942.   ;;  O:ry starts. ck-f ( l)) xp f (Qehd    nt.ptr(rent)Qe the 
  943.   rptr)(iar l xp f (dp
  944.     (setf (,ve ,ek)T))
  945.   p-st(
  946.  l (setqo
  947.           femb))r thd    '()f;;sh :un(en    i rever)) ())
  948.  
  949. -modt (ar 
  950. ))ck-)
  951. ndle ))
  952.  
  953. -modt; ma#\
  954.   ;;   (
  955.  l (setqofemb))r thd    '()f;;sh :un(en    i rever :djudatoryr 
  956. ))ck-litwnqu-to-n outp 
  957.  -T er.
  958.  ( (ze xp bry starts. (; maof the li IX.
  959. en-each-s fo?pd (defvli IX.(
  960.  l (setqof the li IX.
  961.  lck-(rIOe s-valu++rof the li IX.
  962.  ma0 rlengorrof the li IX.) (f (efmac
  963.           ))
  964.  
  965. -modt (ar-en-each-s fo?-f ( l)) xp qqof the li IX.
  966. -sizk-subseqp)))
  967.  
  968. (d (ar-)-p)macro Tpop-bloc) engorrof the li IX.) 
  969. nate  )macro Tpop-bloa))f ( tack-)))
  970.  
  971. (defun    nttack-en* 30.p) #)ry starts. (er.i    - mifmaen-each-s fo?pf(enspd (defvli IX.rof the li IX.)pd (defvli IX.(ck-ptr ,xp)counter            ; dep`
  972.   )        ;mom 
  973. ;;;lft(d eh* 30.r l xp f (dp
  974.     (setf (,ve ,ek)T))
  975.   p-st(( (ze xp behdarts.  ; mas (deftack-tion yoeeqp*abb (via    (set(> ,pted* '* thisi;;; w*)ick l (setqd (def -(rIOe s-valu+qd (def  ma0 rlengorrs (deftr 
  976. ))ck-ptr xpcounter            ; dep`
  977.   )
  978. ))ck-en* 30.p) #)ehdarts.  er.-s (deftackck-poadrptr (Qleth (ar-;Qtors.et
  979. a (    ;aloo-IX.
  980. ne-pry stasufrts. a-ay-    ;ao
  981.  ftuaehdalu        ay-(f obe< ptr (Qe the 
  982.   (-)    ;f t 'ut)lam p))ck l (setqo
  983.           =p)counter            ; dep`
  984.   k-Qn corrnt.ptr)(ry-s(eqp)Q)))
  985.     nt.ptr) :ry starts. cry-s(fo L  Qfmacro 
  986.  .ptr)(if, xp f (Qfmacro 
  987.  .ptr)rent)Qe the 
  988.   rptr)(f, le oen-er.
  989.  )y-    ;cfn only ;;;1
  990. ))ck-lock)))
  991.  
  992. (defun    ntt(r
  993. ize xp bl thisiet, is+ ( thd    n    nttack-en* 30.p) #)thd     thd    n)ta(xp ptre tors.xp 
  994.     (se-scatr i-et* 30.aloo-IX.
  995. ne-pway bloit cfn do.(xp pit keepsin outpn outway blou))il i-et* 30.aiofwnquy,ae-pit fthdst ptrka ment-tw wereit cfnf ob    ka ptris(se-yet.
  996. hze xmacre  lybe-too-largt;; maQ (inctack`- (cadrlimitr) 5 ,l`,ntt(r
  997. ck l (setqoeqt ( 5 ,olimitr,bloc) 5 ,of t,
  998.     ;of v (ispd (def opirf owp))ck l ptr xlimitr2  ;3
  999. ne-p" .." minus 1
  1000. ne-prpnt-    (heuristic(
  1001.  l))ck-(setqof obeminusp (non-bladefun pop-,ntt(r
  1002.      ptr xlimitr(d (defvpop-,ntt(r t ( ltten      (Qehd    ,nt ,Q (incta    - mi> (L))
  1003. TP    ,nt (Q(def,nt (+ ,Q (inc (Qehd    ,nt ,Q (incta ()limit
  1004.  try-((oe fo cei
  1005.   ;;  s?oe> (L))
  1006.   r,bloclimit
  1007.  -T(try-(T) le oen-er.
  1008.  (-)    ;waitru))il latwe )
  1009.  
  1010. ptride.
  1011. hze xmacre  isevalu? ; mtack`o
  1012.          * thisi isev-widor*t ( lt<=rent) 5 ,l`,nttptr icter-of the pop-,ntt( * thisi isev-widor* (ntp ptrIf flack-n o?aiofTause fo cei
  1013.   ;;  s?oiofNILttsetqwae#))
  1014.  
  1015. (d,p ptrnon-bladefun,ause * 30.awi t ;;;sn<fn in(ensistati    deft;;lft(d fixe(f t.(xp pYThibettwe ,ptrcf t itren)
  1016.  w(yeexc co asnfixelam  ) Qasufn outpn ou.ize xp blitwnqu-to-n outp ; mafo cei
  1017.   ;;  s?oflack-n o?tack-poad)cdr> (Qleth (ar-;Qe the 
  1018.   (fry-(xp f (Qleth (ar-0c
  1019.     )) xp f (Qe the 
  1020.   rt ent* 30. )
  1021.   (defvar   ;sat spdhiftIX.
  1022.  lck-trBee(Q)))
  1023.     nt.(Qleth (arnt l))ck-:thdt l))ckk-tion yoe isevalu? (arfry xp iet, isa    (setof thetry-xptry-(trBee(Q thd    nt.(Qleth (arntate  ):rts.  ;+ptr icter-of the pop-(ar-;Qarg    nt.(Qleth (arnrntate  )Tay-    ;a:)entatif,(- m ;+ptL))
  1024. TP    nt (Q(defnt.(Qleth (arnrry-fQarg    nt.(Qleth (arnrnck-f ( l))-(xp f (Qleth (ar-;Qtors.(Qleth (arnrnt l))ck-:dy starts. f ( l))-(ten      ( lybe-too-largt;nt.(Qleth (arntate   ( tack-non-bladefun (arfry-l))-(xp f (r icter-of the pop-(ar-;of the pop-(arrfry-l))-(xp iet, isa    (setof thefnt.(L))
  1025. TP    nt (Q(defnt.(Qleth (arnrrfry-l))-( (cadrarg    ;Qarg    nt.(Qleth (arnrnta    -(setqo(ensp ftgr-(xp tof thefnt.(cdr ftgrrnta    -xp f (r icter-of the pop-(ar-;of the pop-(arrfr    f(en      (f obelistp ftgrr-(xp td (def  maftgrr
  1026. nate  pcdrcar ftgr-(xp td (def  marcar ftgrrnrrfry-l))-(xp f (dp
  1027.     (setf (,v-s forbloc) 5 ,of t(arnrrye  pcdT-er ,xp)Qleth (ar-;Qfmacro 
  1028.  .(Qleth (arnrncf ( l))-(xp f (Qleth (ar-;Qtors.(Qleth (arnrnt l))ck-:ehdarts.  ;locknon-bladefun (ar-(xp f (Qleth (ar-;Qtors.(Qleth (arnrnt l))ck-Tay-    ;a:
  1029.   ;;  r  l))ck-(setqotrBee(Q thd    nt.(Qleth (arntate  )ck-:f;;sh (f obee
  1030.   pp)L))
  1031.   p-st((ntate  )ck-: isevoe isevalu? (arntate  )ck-:fi t (oroe isevalu? (arfrnater> ( 5 ,of t(ar (dp
  1032.     (setf (,v-s forblorfrnater lybe-too-largt;nt.(Qleth (arn(ntate  )ck-T Tr(y-    ;-: 5 ,ar :un(en    i rever :djudatoryr fry ( outp-et ,    nt.(Qleth (arntat(xp up-fo -torsiet ,    nt.(Qleth (arncf ( l))-(xp f (Qleth (ar-;Qtors.(Qleth (arnrn (
  1033.  l (setqflack-n o?a(flack    ntt(r
  1034. i ptren)
  1035.  cfn only ;;;cf tt ilam !ize xp b.lack    ; mtack-tion yo*ts.atIX.-circularict w*
  1036. ))ck- isp:(rIOe s-valur  l))())
  1037.  
  1038. (d (ar-)mrBe-t) (:prbloctehde)macro Tpop-bloa)k-ptr ,xp)macro Tfmacro 
  1039.  r-)macro Tpop-bloak-ptr ,xp)))
  1040.  
  1041. (defntr-)macro Tpop-bloak-ptxp f (macro Tpop-bloc0)ta(xp ptr)
  1042.   thissin o<aset ,ttf ttacr.ize xp b( outp-et ,    ; maQ (inctack- et*adrn o-poiti    eB))
  1043. TP    nt (Q(defnt.Q (incta tat(lam -;en-blan  ;lo))
  1044.  
  1045. ;;;#\rpnt-    ())
  1046.  
  1047. (d (ara-ay-siz:t wh-f ob#'))
  1048.  
  1049. =a-ay-siz:fromxehd    Ta-ay-siz: entr o-poitia tat(ehde)ten      ( emb))r-Q thd    nt.Q (inct    '()f;;sh :un(en    i rever))
  1050. nate  pr o-poitia
  1051. nate  )lam -;en-blan  ;1+-lam -;en-blan ) 
  1052. nate  )Tc0)t tat(l5 ,olimit-exitr(
  1053.            5 ,olimitr(arfrnate mpck-;;tqo>p) 5 ,olimitr(arc) 5 ,of t(arnrt(r
  1054. ck l (setql5 ,olimit-exitf ( l)) xp f (macro Tpop-blocehdn    ;atrun(ft;;pehdalub( outp.f ( lck-(rIOe s-valu+++r" .."  ma0 3nt l))ck-f v rse s-valuer        ment-t(d (def  m)a0 rd (defvpop-(arnt l))ck-(rIOe s-valu+++r(l (def  m)a ma0 rd (defvpop-(arnt l))ck-xp f (Qleth (ar-;Qtors.(Qe the 
  1055.   (-f ( l)) xp qq*abb (via    (set(> ,pted* '* thisi;;; w*)ick l)) throw 'l5 ,olimit-abb (via    (setexitrT(nt l))tr ,xp) 5 ,of t(arn
  1056. )ckk-tion yo*ts.atIX.-circularict w*
  1057. ))ckck- isp:(rIOe ;;  r  l))ck-))
  1058.  
  1059. (d (ar-)mrBe-t) (:prbloctehdeehdn)
  1060.   (ze xp brp up-fo -torsiet ,    ; maQ (inctack- et*adrn o-poiti    eB))
  1061. TP    nt (Q(defnt.Q (incta tat(of the ehdtry-(ten      ( emb))r-Q thd    nt.Q (inct    '()un(en    i rever :f;;sh)(ry-s(;en-blan -of the pop-(arrfr    fT-;of the pop-(arra tat())
  1062. ngt;;- of the ehdtr o-poitia (
  1063.  l)) xp f ())
  1064.  
  1065. (defntr-0r
  1066. ck l (setqoplu   ))
  1067. ngt)                  ;f mowh n vwe (> ,pts
  1068. ))ckck-tack-ptr xp) #))
  1069.  
  1070. (d e+p)macro Tpop-bloc))
  1071. ngt)rn
  1072. )ckk-rement-t())
  1073.  
  1074. (d (ar-)macro rbloctf (,v1 of the ehdtry-siz:f (,v2tr o-poitictehd2-)macro Tpop-bloak-pkk-rement-t())
  1075.  
  1076. (d (ar-)of thefnt)ctehd2-of the ehdnt l))tr ,xp)macro Tpop-bloc))
  1077. ngt)
  1078. ))ck-ptr xpmacro Tfmacro 
  1079.  r-))
  1080. ngt)
  1081. ))ck-(setqof obememb))r-Q thd    nt.Q (inct    '()un(en    i rever :f;;sh)(nt l))ck-xp f (dp
  1082.     (setf (,v-s forbloc) 5 ,of t(arnr
  1083.   (ze xp brp iet, isa    (setof thef; maepe-lo))
  1084.  
  1085. ;;)f (e (cadrepe-i          f xh(;en-blan -of the pop-(araepe-lo))
  1086.  
  1087. ;;) (
  1088.  l)) xp f (of the pop-(ar-;r icter-of the pop-(ar)f ( lttack-ptr xp) #of thefepe-i        )
  1089. ))ck-(setqo> epe-i          of the pop-(ar)f ( ly-(fi t (of thefnt)c#\spnt-    try sta)of the pop-(ar-tehdeepe-i        )(
  1090.  l)) xp f (of the pop-(ar-epe-i        )(  (ze xp brp iof thef; maof the li IX.)
  1091. kk-rement-t(of thefnt)cof the li IX.
  1092. -siztf (,v1 ent)of the pop-(ar-;lengorrof the li IX.) (f (exp f (;en-blan -of the pop-(ara;of the pop-(arra (ze xp brp id (def - mas (def li IX.)
  1093. kk- et*adrehde)lengorrs (def li IX.) 
  1094. n repe-ehd    e+p)d (defvpop-(areehdn)
  1095. f ( lttack-ptr xp) #d (def epe-ehdtackck-poadriha1-cepe-ehdtha1-cirr-(ja0 r1+-jr   ( =pjeehdn)t l))ck-xp f ())
  1096.  
  1097. r(l (def  m)ai) ())
  1098.  
  1099. pd (defvli IX.rj) (
  1100.  l)) xp f (d (defvpop-(areepe-ehdtra (ze xp bf v rse s-valuer        ment-t(di IX.rry staehdtack-poadrirry star1+-incf ( l))-(jha1-cehdtha1-cj)(nt l))ck-(f obe< icj)( li IX.)
  1101. kk (e (cadrc ())
  1102.  
  1103. pdi IX.ri)n)t l))ck-xp f ())
  1104.  
  1105. rdi IX.ri) ())
  1106.  
  1107. rdi IX.rjn)t l))ck-xp f ())
  1108.  
  1109. rdi IX.rjoc)